home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / CGI / Util.pm < prev   
Text File  |  2006-04-25  |  11KB  |  319 lines
  1. package CGI::Util;
  2.  
  3. use strict;
  4. use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7. @EXPORT_OK = qw(rearrange make_attributes unescape escape 
  8.         expires ebcdic2ascii ascii2ebcdic);
  9.  
  10. $VERSION = '1.5';
  11.  
  12. $EBCDIC = "\t" ne "\011";
  13. # (ord('^') == 95) for codepage 1047 as on os390, vmesa
  14. @A2E = (
  15.    0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
  16.   16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
  17.   64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
  18.  240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
  19.  124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
  20.  215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
  21.  121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
  22.  151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
  23.   32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
  24.   48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
  25.   65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
  26.  144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
  27.  100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
  28.  172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
  29.   68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
  30.  140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
  31.      );
  32. @E2A = (
  33.    0,  1,  2,  3,156,  9,134,127,151,141,142, 11, 12, 13, 14, 15,
  34.   16, 17, 18, 19,157, 10,  8,135, 24, 25,146,143, 28, 29, 30, 31,
  35.  128,129,130,131,132,133, 23, 27,136,137,138,139,140,  5,  6,  7,
  36.  144,145, 22,147,148,149,150,  4,152,153,154,155, 20, 21,158, 26,
  37.   32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
  38.   38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
  39.   45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
  40.  248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
  41.  216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
  42.  176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
  43.  181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
  44.  172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
  45.  123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
  46.  125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
  47.   92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
  48.   48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
  49.      );
  50.  
  51. if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
  52.      $A2E[91] = 187;   $A2E[92] = 188;  $A2E[94] = 106;  $A2E[96] = 74;
  53.      $A2E[123] = 251;  $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
  54.      $A2E[162] = 176;  $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
  55.      $A2E[175] = 161;  $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
  56.      $A2E[249] = 192;
  57.  
  58.      $E2A[74] = 96;   $E2A[95] = 159;  $E2A[106] = 94;  $E2A[121] = 168;
  59.      $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
  60.      $E2A[187] = 91;  $E2A[188] = 92;  $E2A[192] = 249; $E2A[208] = 166;
  61.      $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
  62.      $E2A[255] = 126;
  63.    }
  64. elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
  65.   $A2E[10] = 37;  $A2E[91] = 186;  $A2E[93] = 187; $A2E[94] = 176;
  66.   $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
  67.  
  68.   $E2A[21] = 133; $E2A[37] = 10;  $E2A[95] = 172; $E2A[173] = 221;
  69.   $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
  70. }
  71.  
  72. # Smart rearrangement of parameters to allow named parameter
  73. # calling.  We do the rearangement if:
  74. # the first parameter begins with a -
  75. sub rearrange {
  76.     my($order,@param) = @_;
  77.     return () unless @param;
  78.  
  79.     if (ref($param[0]) eq 'HASH') {
  80.     @param = %{$param[0]};
  81.     } else {
  82.     return @param 
  83.         unless (defined($param[0]) && substr($param[0],0,1) eq '-');
  84.     }
  85.  
  86.     # map parameters into positional indices
  87.     my ($i,%pos);
  88.     $i = 0;
  89.     foreach (@$order) {
  90.     foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
  91.     $i++;
  92.     }
  93.  
  94.     my (@result,%leftover);
  95.     $#result = $#$order;  # preextend
  96.     while (@param) {
  97.     my $key = lc(shift(@param));
  98.     $key =~ s/^\-//;
  99.     if (exists $pos{$key}) {
  100.         $result[$pos{$key}] = shift(@param);
  101.     } else {
  102.         $leftover{$key} = shift(@param);
  103.     }
  104.     }
  105.  
  106.     push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
  107.     @result;
  108. }
  109.  
  110. sub make_attributes {
  111.     my $attr = shift;
  112.     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  113.     my $escape =  shift || 0;
  114.     my(@att);
  115.     foreach (keys %{$attr}) {
  116.     my($key) = $_;
  117.     $key=~s/^\-//;     # get rid of initial - if present
  118.  
  119.     # old way: breaks EBCDIC!
  120.     # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
  121.  
  122.     ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
  123.  
  124.     my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
  125.     push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
  126.     }
  127.     return @att;
  128. }
  129.  
  130. sub simple_escape {
  131.   return unless defined(my $toencode = shift);
  132.   $toencode =~ s{&}{&}gso;
  133.   $toencode =~ s{<}{<}gso;
  134.   $toencode =~ s{>}{>}gso;
  135.   $toencode =~ s{\"}{"}gso;
  136. # Doesn't work.  Can't work.  forget it.
  137. #  $toencode =~ s{\x8b}{‹}gso;
  138. #  $toencode =~ s{\x9b}{›}gso;
  139.   $toencode;
  140. }
  141.  
  142. sub utf8_chr {
  143.         my $c = shift(@_);
  144.     return chr($c) if $] >= 5.006;
  145.  
  146.         if ($c < 0x80) {
  147.                 return sprintf("%c", $c);
  148.         } elsif ($c < 0x800) {
  149.                 return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
  150.         } elsif ($c < 0x10000) {
  151.                 return sprintf("%c%c%c",
  152.                                            0xe0 |  ($c >> 12),
  153.                                            0x80 | (($c >>  6) & 0x3f),
  154.                                            0x80 | ( $c          & 0x3f));
  155.         } elsif ($c < 0x200000) {
  156.                 return sprintf("%c%c%c%c",
  157.                                            0xf0 |  ($c >> 18),
  158.                                            0x80 | (($c >> 12) & 0x3f),
  159.                                            0x80 | (($c >>  6) & 0x3f),
  160.                                            0x80 | ( $c          & 0x3f));
  161.         } elsif ($c < 0x4000000) {
  162.                 return sprintf("%c%c%c%c%c",
  163.                                            0xf8 |  ($c >> 24),
  164.                                            0x80 | (($c >> 18) & 0x3f),
  165.                                            0x80 | (($c >> 12) & 0x3f),
  166.                                            0x80 | (($c >>  6) & 0x3f),
  167.                                            0x80 | ( $c          & 0x3f));
  168.  
  169.         } elsif ($c < 0x80000000) {
  170.                 return sprintf("%c%c%c%c%c%c",
  171.                                            0xfc |  ($c >> 30),
  172.                                            0x80 | (($c >> 24) & 0x3f),
  173.                                            0x80 | (($c >> 18) & 0x3f),
  174.                                            0x80 | (($c >> 12) & 0x3f),
  175.                                            0x80 | (($c >> 6)  & 0x3f),
  176.                                            0x80 | ( $c          & 0x3f));
  177.         } else {
  178.                 return utf8_chr(0xfffd);
  179.         }
  180. }
  181.  
  182. # unescape URL-encoded data
  183. sub unescape {
  184.   shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  185.   my $todecode = shift;
  186.   return undef unless defined($todecode);
  187.   $todecode =~ tr/+/ /;       # pluses become spaces
  188.     $EBCDIC = "\t" ne "\011";
  189.     if ($EBCDIC) {
  190.       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
  191.     } else {
  192.       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
  193.     defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
  194.     }
  195.   return $todecode;
  196. }
  197.  
  198. # URL-encode data
  199. sub escape {
  200.   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
  201.   my $toencode = shift;
  202.   return undef unless defined($toencode);
  203.   # force bytes while preserving backward compatibility -- dankogai
  204.   $toencode = pack("C*", unpack("C*", $toencode));
  205.     if ($EBCDIC) {
  206.       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
  207.     } else {
  208.       $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  209.     }
  210.   return $toencode;
  211. }
  212.  
  213. # This internal routine creates date strings suitable for use in
  214. # cookies and HTTP headers.  (They differ, unfortunately.)
  215. # Thanks to Mark Fisher for this.
  216. sub expires {
  217.     my($time,$format) = @_;
  218.     $format ||= 'http';
  219.  
  220.     my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  221.     my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
  222.  
  223.     # pass through preformatted dates for the sake of expire_calc()
  224.     $time = expire_calc($time);
  225.     return $time unless $time =~ /^\d+$/;
  226.  
  227.     # make HTTP/cookie date string from GMT'ed time
  228.     # (cookies use '-' as date separator, HTTP uses ' ')
  229.     my($sc) = ' ';
  230.     $sc = '-' if $format eq "cookie";
  231.     my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
  232.     $year += 1900;
  233.     return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
  234.                    $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
  235. }
  236.  
  237. # This internal routine creates an expires time exactly some number of
  238. # hours from the current time.  It incorporates modifications from 
  239. # Mark Fisher.
  240. sub expire_calc {
  241.     my($time) = @_;
  242.     my(%mult) = ('s'=>1,
  243.                  'm'=>60,
  244.                  'h'=>60*60,
  245.                  'd'=>60*60*24,
  246.                  'M'=>60*60*24*30,
  247.                  'y'=>60*60*24*365);
  248.     # format for time can be in any of the forms...
  249.     # "now" -- expire immediately
  250.     # "+180s" -- in 180 seconds
  251.     # "+2m" -- in 2 minutes
  252.     # "+12h" -- in 12 hours
  253.     # "+1d"  -- in 1 day
  254.     # "+3M"  -- in 3 months
  255.     # "+2y"  -- in 2 years
  256.     # "-3m"  -- 3 minutes ago(!)
  257.     # If you don't supply one of these forms, we assume you are
  258.     # specifying the date yourself
  259.     my($offset);
  260.     if (!$time || (lc($time) eq 'now')) {
  261.         $offset = 0;
  262.     } elsif ($time=~/^\d+/) {
  263.         return $time;
  264.     } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
  265.         $offset = ($mult{$2} || 1)*$1;
  266.     } else {
  267.         return $time;
  268.     }
  269.     return (time+$offset);
  270. }
  271.  
  272. sub ebcdic2ascii {
  273.   my $data = shift;
  274.   $data =~ s/(.)/chr $E2A[ord($1)]/ge;
  275.   $data;
  276. }
  277.  
  278. sub ascii2ebcdic {
  279.   my $data = shift;
  280.   $data =~ s/(.)/chr $A2E[ord($1)]/ge;
  281.   $data;
  282. }
  283.  
  284. 1;
  285.  
  286. __END__
  287.  
  288. =head1 NAME
  289.  
  290. CGI::Util - Internal utilities used by CGI module
  291.  
  292. =head1 SYNOPSIS
  293.  
  294. none
  295.  
  296. =head1 DESCRIPTION
  297.  
  298. no public subroutines
  299.  
  300. =head1 AUTHOR INFORMATION
  301.  
  302. Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
  303.  
  304. This library is free software; you can redistribute it and/or modify
  305. it under the same terms as Perl itself.
  306.  
  307. Address bug reports and comments to: lstein@cshl.org.  When sending
  308. bug reports, please provide the version of CGI.pm, the version of
  309. Perl, the name and version of your Web server, and the name and
  310. version of the operating system you are using.  If the problem is even
  311. remotely browser dependent, please provide information about the
  312. affected browers as well.
  313.  
  314. =head1 SEE ALSO
  315.  
  316. L<CGI>
  317.  
  318. =cut
  319.